Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH2/SRC/META.FRM

Text File | 1996-04-18 | 7KB | 256 lines

VERSION 4.00
Begin VB.Form MetaForm
   AutoRedraw      =   -1  'True
   Caption         =   "Metafile"
   ClientHeight    =   4680
   ClientLeft      =   1950
   ClientTop       =   1110
   ClientWidth     =   5415
   Height          =   5370
   Left            =   1890
   LinkTopic       =   "Form1"
   ScaleHeight     =   312
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   361
   Top             =   480
   Width           =   5535
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   0
      Top             =   0
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
      Flags           =   2
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "&Save As..."
         Enabled         =   0   'False
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileClear
         Caption         =   "&Clear"
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "MetaForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Dim Drawing As Boolean
Dim MetafileLoaded As Boolean
Dim PointX() As Single
Dim PointY() As Single
Dim NumPoints As Integer
Dim LastPoint As Integer
Dim LastX As Single
Dim LastY As Single


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Drawing = True
    LastX = x
    LastY = y
    AddPoint -x, y
End Sub
' ***********************************************
' Add a point to the list of points.
' ***********************************************
Sub AddPoint(x As Single, y As Single)
    ' Start over if a metafile is displayed.
    If MetafileLoaded Then
        Cls
        MetafileLoaded = False
        LastPoint = 0
    End If

    LastPoint = LastPoint + 1
    If LastPoint > NumPoints Then
        NumPoints = NumPoints + 100
        ReDim Preserve PointX(1 To NumPoints)
        ReDim Preserve PointY(1 To NumPoints)
    End If
    PointX(LastPoint) = x
    PointY(LastPoint) = y

    If x < 0 Then
        CurrentX = -x
        CurrentY = y
    Else
        Line -(x, y)
    End If

    mnuFileSaveAs.Enabled = True
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Drawing Then Exit Sub

    AddPoint x, y
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Drawing Then Exit Sub
    Drawing = False

    AddPoint x, y
End Sub

Private Sub mnuFileClear_Click()
    Cls
    LastPoint = 0
    mnuFileSaveAs.Enabled = False
End Sub


' ***********************************************
' Load a metafile.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
Dim mhdc As Integer
Dim hMF As Integer
Dim status As Long

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.WMF"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload FileDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload FileDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = FileDialog.filename
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)

    MetafileLoaded = True
    Cls
    mnuFileSaveAs.Enabled = False

    ' Load the metafile.
    hMF = GetMetaFile(fname)
    If hMF = 0 Then
        Beep
        MsgBox "Unable to load metafile " & _
            fname & ".", vbExclamation
        Exit Sub
    End If

    ' Play the metafile.
    If PlayMetaFile(hdc, hMF) = 0 Then
        Beep
        MsgBox "Error playing metafile " & _
            fname & ".", vbExclamation
    End If

    ' Delete the metafile to free resources.
    If DeleteMetaFile(hMF) = 0 Then
        Beep
        MsgBox "Error deleting metafile " & _
            fname & ".", vbExclamation
    End If
    Refresh
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub

' ***********************************************
' Save the drawing in a metafile.
' ***********************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim i As Integer
Dim mhdc As Integer
Dim hMF As Integer
Dim status As Long
Dim x As Single
Dim y As Single

    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.WMF"
    FileDialog.Flags = cdlOFNOverwritePrompt + _
        cdlOFNPathMustExist + cdlOFNHideReadOnly
    FileDialog.ShowSave
    If Err.Number = cdlCancel Then
        Unload FileDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload FileDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = FileDialog.filename
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)

    ' Create the metafile.
    mhdc = CreateMetaFile(ByVal fname)
    If mhdc = 0 Then
        Beep
        MsgBox "Error creating metafile " & _
            fname & ".", vbExclamation
        Exit Sub
    End If

    ' Draw in the metafile.
    For i = 1 To LastPoint
        x = PointX(i)
        y = PointY(i)
        If x < 0 Then
#If Win32 Then
            status = MoveToEx(mhdc, -x, y, ByVal 0&)
#Else
            status = MoveTo(mhdc, -x, y)
#End If
        Else
            status = LineTo(mhdc, x, y)
        End If
    Next i

    ' Close the metafile.
    hMF = CloseMetaFile(mhdc)
    If hMF = 0 Then
        Beep
        MsgBox "Error closing metafile " & _
            fname & ".", vbExclamation
    End If

    ' Delete the metafile to free resources.
    If DeleteMetaFile(hMF) = 0 Then
        Beep
        MsgBox "Error deleting metafile " & _
            fname & ".", vbExclamation
    End If
End Sub